Unit
	RTTIObject;

Interface

{$H+}{$M+}

Uses
 Classes,
 Contnrs,
 StrUtils,
 SysUtils,
	MD5,
 TypInfo;

Const
 tiStreamable : Set Of TTypeKind = [
  tkUnknown,
  tkInteger,
  tkChar,
  tkEnumeration,
  tkFloat,
  tkSet,
  tkMethod,
  tkSString,
  tkLString,
  tkAString,
  tkWString,
  tkVariant,
  tkArray,
  tkRecord,
  tkInterface,
  tkClass,
  tkObject,
  tkWChar,
  tkBool,
  tkInt64,
  tkQWord,
  tkDynArray,
  tkInterfaceRaw,
  tkProcVar,
  tkUString,
  tkUChar
  ];

Type
 EComponentLoader = Class(Exception);
	
 TComponentNode = Class;
	TComponentNodeClass = Class Of TComponentNode;
	TComponentNodeArray = Array Of TComponentNode;
 TComponentNode = Class(TObject)
 Private
		fInstanceName : String;
  fOwner : TComponentNode;
  fChilds : TComponentNodeArray;
		Function GetChildCount: Integer;
 Public
  Constructor Create(Const aInstanceName : String); Virtual;
  Function FindUpward(Const aClass : TComponentNodeClass) : TComponentNode; Virtual;
		Class Function AcceptChild(Const aChild : TComponentNode): Boolean; Virtual;
		Procedure Append(Const aChild : TComponentNode); Virtual;
		Procedure Delete(Const aChild : TComponentNode); Virtual;
		Procedure Purge; Virtual;
		Property InstanceName : String Read fInstanceName Write fInstanceName;
  Property Owner : TComponentNode Read fOwner Write fOwner;
  Property Childs : TComponentNodeArray Read fChilds;
		Property ChildCount : Integer Read GetChildCount;
 End;
	
	TArrayOfString = Array Of String;

	TComponentMessage = Record
		MsgStr : String[255];
		Data : Pointer;
	End;

 TRTTIObject = Class(TComponentNode)
 Private
  fTypeData : PTypeData;
  fPropList : PPropList;
  fCount : Integer;
  Function GetPropertyValue(Const aIndex : Integer) : String;
  Procedure SetPropertyValue(Const aIndex : Integer; Const aValue : String); Overload;
  Function GetPropertyValueByName(Const aName : String) : String;
  Procedure SetPropertyValueByName(Const aName, aValue : String); Overload;
 Public
  Function GetPropertyIndex(Const aName : String) : Integer;
	 Function GetPropertyName(Const aIndex : Integer) : String;
  Function GetPropertyType(Const aIndex : Integer) : String;
		Function IsObjectProperty(Const aIndex : Integer) : Boolean;
		Function GetEnumPropertyPossibleValues(Const aName : String): TArrayOfString;
  Property Properties[aName : String] : String Read GetPropertyValueByName Write SetPropertyValueByName;
  Property PropertiesByIndex[aIndex : Integer] : String Read GetPropertyValue Write SetPropertyValue;
  Property PropertyCount : Integer Read fCount;
  Procedure InitRTTI;
  Procedure DoneRTTI;
		Function AllProperties: String;
		Function AsPONString(aDepth : Integer): String;
		Procedure Submit; Virtual;
		Procedure Process; Virtual;
		Function Show: String; Virtual;
		Function ShowChilds: String; Virtual;
		// Procedure AfterShow; Virtual;
		Procedure DispatchEvent(Const aName : String);
 // Published
  Property InstanceName : String Read fInstanceName Write fInstanceName;
 End;
	
 TRTTIObjectClass = Class Of TRTTIObject;

 TRTTIClassFactory = Class(TObject)
 Private
  fLastID : Integer;
  fClasses : TClassList;
  fInstances : TObjectList;
 Public
  Constructor Create;
  Destructor Destroy; Override;
  Procedure Register(Const aClass : TRTTIObjectClass);
  Function Instance(Const aClassName, aInstanceName : String) : TRTTIObject;
		Function Clone(Const aInstanceName : String) : TRTTIObject;
		Function FindInstance(Const aInstanceName : String): TRTTIObject;
  Function UniqueID : String;
		Procedure FindNameless;
 End;

Var
	Factory : TRTTIClassFactory;

Implementation

// TComponentNode

Function TComponentNode.GetChildCount: Integer;
Begin
	Result := Length(fChilds);
End;

Constructor TComponentNode.Create(Const aInstanceName : String);
Begin
	Inherited Create;
	fInstanceName := aInstanceName;
	SetLength(fChilds, 0);
End;

Function TComponentNode.FindUpward(Const aClass : TComponentNodeClass) : TComponentNode;
Begin
	If Assigned(fOwner) Then
		If fOwner Is aClass Then
			Result := fOwner
		Else
			Result := fOwner.FindUpward(aClass)
	Else
		Result := Nil;
End;

Class Function TComponentNode.AcceptChild(Const aChild : TComponentNode): Boolean;
Begin
	Result := True;
End;

Procedure TComponentNode.Append(Const aChild : TComponentNode);
Begin
	SetLength(fChilds, Length(fChilds) + 1);
	fChilds[High(fChilds)] := aChild;
	aChild.Owner := Self;
End;

Procedure TComponentNode.Delete(Const aChild : TComponentNode);
Var
	lCtrl1,
	lCtrl2 : Integer;
Begin
	For lCtrl1 := Low(fChilds) To High(fChilds) Do
		If fChilds[lCtrl1] = aChild Then
			For lCtrl2 := lCtrl1 To High(fChilds) - 1 Do
				fChilds[lCtrl2] := fChilds[lCtrl2 + 1];
	SetLength(fChilds, Length(fChilds) - 1);
End;

Procedure TComponentNode.Purge;
Begin
	SetLength(fChilds, 0);
End;

// TRTTIObject

Function TRTTIObject.GetPropertyName(Const aIndex : Integer) : String;
Begin
 Result := fPropList^[aIndex]^.Name;
End;

Function TRTTIObject.GetPropertyType(Const aIndex : Integer) : String;
Begin
 Result := fPropList^[aIndex]^.PropType^.Name;
End;

Function TRTTIObject.IsObjectProperty(Const aIndex : Integer) : Boolean;
Begin
	Result := fPropList^[aIndex]^.PropType^.Kind = tkClass;
End;

Function TRTTIObject.GetEnumPropertyPossibleValues(Const aName : String): TArrayOfString;
Var
	lCtrl : Integer;
Begin
	SetLength(Result, 0);
	For lCtrl := 0 To GetEnumNameCount(FindPropInfo(Self, aName)^.PropType) Do
	Begin
		SetLength(Result, Length(Result) + 1);
		Result[High(Result)] := GetEnumName(FindPropInfo(Self, aName)^.PropType, lCtrl);
	End;
End;

Function TRTTIObject.GetPropertyValue(Const aIndex : Integer) : String;
Var
	lTemp : TRTTIObject;
Begin
 Case fPropList^[aIndex]^.PropType^.Kind Of
  tkUnknown :
   Result := '';
  tkInteger :
   Result := IntToStr(GetInt64Prop(Self, GetPropertyName(aIndex)));
  tkChar :
   Result := GetStrProp(Self, GetPropertyName(aIndex));
  tkEnumeration :
   Result := GetEnumProp(Self, GetPropertyName(aIndex));
  tkFloat :
   Result := FloatToStr(GetFloatProp(Self, GetPropertyName(aIndex)));
  tkSet :
   Result := GetSetProp(Self, GetPropertyName(aIndex), True);
  tkMethod :
   Result := '';
  tkSString :
   Result := GetStrProp(Self, GetPropertyName(aIndex));
  tkLString :
   Result := GetStrProp(Self, GetPropertyName(aIndex));
  tkAString :
   Result := GetStrProp(Self, GetPropertyName(aIndex));
  tkWString :
   Result := GetWideStrProp(Self, GetPropertyName(aIndex));
  tkVariant :
   Result := GetVariantProp(Self, GetPropertyName(aIndex));
  tkArray :
   Result := '';
  tkRecord :
   Result := '';
  tkInterface :
   Result := '';
  tkClass :
		Begin
			lTemp := GetObjectProp(Self, GetPropertyName(aIndex)) As TRTTIObject;
			If Assigned(lTemp) Then
				Result := (lTemp As TRTTIObject).InstanceName
			Else
				Result := '';
		End;
  tkObject :
   Result := '';
  tkWChar :
   Result := GetWideStrProp(Self, GetPropertyName(aIndex));
  tkBool :
   Result := GetEnumProp(Self, GetPropertyName(aIndex));
  tkInt64 :
   Result := IntToStr(GetInt64Prop(Self, GetPropertyName(aIndex)));
  tkQWord :
   Result := IntToStr(GetInt64Prop(Self, GetPropertyName(aIndex)));
  tkDynArray :
   Result := '';
  tkInterfaceRaw :
   Result := '';
  tkProcVar :
   Result := '';
  tkUString :
   Result := '';
  tkUChar :
   Result := '';
 End;
End;

Procedure TRTTIObject.SetPropertyValue(Const aIndex : Integer; Const aValue : String);
Var
	lTarget : TRTTIObject;
Begin
	// Debug  WriteLn('Property ', GetPropertyName(aIndex), ' value ', aValue, ' of object ', Self.InstanceName, ' is ', fPropList^[aIndex]^.PropType^.Kind);
 Case fPropList^[aIndex]^.PropType^.Kind Of
  tkUnknown : ;
  tkInteger :
   SetOrdProp(Self, GetPropertyName(aIndex), StrToInt64Def(aValue, 0));
  tkChar :
   SetStrProp(Self, GetPropertyName(aIndex), aValue);
  tkEnumeration :
   SetEnumProp(Self, GetPropertyName(aIndex), aValue);
  tkFloat :
   SetFloatProp(Self, GetPropertyName(aIndex), StrToFloatDef(aValue, 0));
  tkSet :
   SetSetProp(Self, GetPropertyName(aIndex), aValue);
  tkMethod : ;
  tkSString :
   SetStrProp(Self, GetPropertyName(aIndex), aValue);
  tkLString :
   SetStrProp(Self, GetPropertyName(aIndex), aValue);
  tkAString :
   SetStrProp(Self, GetPropertyName(aIndex), aValue);
  tkWString :
   SetStrProp(Self, GetPropertyName(aIndex), aValue);
  tkVariant :
   SetVariantProp(Self, GetPropertyName(aIndex), aValue);
  tkArray : ;
  tkRecord : ;
  tkInterface : ;
  tkClass : 
		Begin
			// Debug  WriteLn('Setting object property ', GetPropertyName(aIndex));
			If aValue = '' Then
				SetObjectProp(Self, GetPropertyName(aIndex), Nil)
			Else
			Begin
				lTarget := Factory.FindInstance(aValue);
				If lTarget = Nil Then
					lTarget := Factory.Instance(GetObjectPropClass(Self, GetPropertyName(aIndex)).ClassName, aValue);
				SetObjectProp(Self, GetPropertyName(aIndex), lTarget);
			End;
		End;
  tkObject : ;
  tkWChar : ;
  tkBool :
   SetEnumProp(Self, GetPropertyName(aIndex), aValue);
  tkInt64 :
   SetInt64Prop(Self, GetPropertyName(aIndex), StrToInt64Def(aValue, 0));
  tkQWord :
   SetInt64Prop(Self, GetPropertyName(aIndex), StrToInt64Def(aValue, 0));
  tkDynArray : ;
  tkInterfaceRaw : ;
  tkProcVar : ;
  tkUString : ;
  tkUChar : ;
 End;
End;

Function TRTTIObject.GetPropertyIndex(Const aName : String) : Integer;
Var
 lRow : Integer;
Begin
	Result := -1;
 For lRow := 0 To fCount - 1 Do
  If LowerCase(fPropList^[lRow]^.Name) = LowerCase(aName) Then
  Begin
   Result := lRow;
   Exit;
  End;
End;

Function TRTTIObject.GetPropertyValueByName(Const aName : String) : String;
Begin
 Result := GetPropertyValue(GetPropertyIndex(aName));
End;

Procedure TRTTIObject.SetPropertyValueByName(Const aName, aValue : String);
Begin
 SetPropertyValue(GetPropertyIndex(aName), aValue);
End;

Procedure TRTTIObject.InitRTTI;
Begin
 fTypeData := GetTypeData(Self.ClassInfo);
 GetMem(fPropList, fTypeData^.PropCount * SizeOf(Pointer));
 fCount := GetPropList(Self.ClassInfo, tiStreamable, fPropList);
End;

Procedure TRTTIObject.DoneRTTI;
Begin
 FreeMem(fPropList, fTypeData^.PropCount * SizeOf(Pointer));
End;

Function TRTTIObject.AllProperties: String;
Var
	lCtrl : Integer;
Begin
	Result := '(';
	If fCount > 0 Then
	Begin
		For lCtrl := 0 To fCount - 1 Do
			If lCtrl = 0 Then
				Result := Result + GetPropertyName(lCtrl) + ':=''' + PropertiesByIndex[lCtrl] + ''''
			Else
				Result := Result + ';' + GetPropertyName(lCtrl) + ':=''' + PropertiesByIndex[lCtrl] + '''';
		Result := Result;
	End;
	Result := Result + ')';
End;

Function TRTTIObject.AsPONString(aDepth : Integer): String;
Var
	lCtrl : Integer;
Begin
	Result := Space(aDepth * 2) + 'class ' + InstanceName + ' of ' + ClassName + AllProperties;
	If ChildCount > 0 Then
	Begin
		Result := Result + #13#10 + Space(aDepth * 2) + 'begin' + #13#10;
		For lCtrl := Low(Childs) To High(Childs) Do
			If lCtrl = 0 Then
				Result := Result + (Childs[lCtrl] As TRTTIObject).AsPONString(aDepth + 1)
		 Else
				Result := Result + ';' + #13#10 + (Childs[lCtrl] As TRTTIObject).AsPONString(aDepth + 1);
		Result := Result + #13#10 + Space(aDepth * 2) + 'end ';
	End;
End;

Procedure TRTTIObject.Submit;
Var
	lCtrl : Integer;
Begin
	For lCtrl := Low(Childs) To High(Childs) Do
		(Childs[lCtrl] As TRTTIObject).Submit;
End;

Procedure TRTTIObject.Process;
Var
	lCtrl : Integer;
Begin
	For lCtrl := Low(Childs) To High(Childs) Do
		(Childs[lCtrl] As TRTTIObject).Process;
End;

Function TRTTIObject.Show: String;
Begin
	Result := '';
End;

Function TRTTIObject.ShowChilds: String;
Var
	lCtrl : Integer;
Begin
	Result := '';
	For lCtrl := Low(Childs) To High(Childs) Do
	Begin
		// Debug WriteLn(Childs[lCtrl].InstanceName);
		Result := Result + (Childs[lCtrl] As TRTTIObject).Show;
	End;
End;

Procedure TRTTIObject.DispatchEvent(Const aName : String);
Var
	Msg : TComponentMessage;
Begin
	Msg.MsgStr := aName;
	Msg.Data := Nil;
	DispatchStr(Msg);
End;

// TRTTIClassFactory

// Creates the class factory... (Obviously)
Constructor TRTTIClassFactory.Create;
Begin
 Inherited Create;
 fLastID := 0;
  // Class prototypes
 fClasses := TClassList.Create;
  // Class instances
 fInstances := TObjectList.Create(True);
	Register(TRTTIObject);
End;

// Destroy the class factory... (As you imagined)
Destructor TRTTIClassFactory.Destroy;
Var
 lRow : Integer;
Begin
 For lRow := 0 To fInstances.Count - 1 Do
		If Assigned(fInstances[lRow]) Then
  (fInstances[lRow] As TRTTIObject).DoneRTTI;
 fClasses.Free;
 fInstances.Pack;
 fInstances.Free;
 Inherited Destroy;
End;

// Registers a class
Procedure TRTTIClassFactory.Register(Const aClass : TRTTIObjectClass);
Begin
 fClasses.Add(aClass);
End;

// Creates a new class instance of the class defined by ClassTag
Function TRTTIClassFactory.Instance(Const aClassName, aInstanceName : String) : TRTTIObject;
Var
 lRow : Integer;
 lTemp : TRTTIObject;
Begin
	// Debug WriteLn('Class ', aClassName, ' Instance ', aInstanceName);
 For lRow := 0 To fClasses.Count - 1 Do
  If LowerCase(TRTTIObjectClass(fClasses.Items[lRow]).ClassName) = LowerCase(aClassName) Then
  Begin
   lTemp := TRTTIObjectClass(fClasses.Items[lRow]).Create(aInstanceName);
   lTemp.InitRTTI;
   fInstances.Add(lTemp);
   Result := lTemp;
			Exit;
  End;
		If Not(Assigned(Result)) Then
			Raise Exception.Create('Must register ' + aClassName + ' at factory before creating one.');
End;

Function TRTTIClassFactory.Clone(Const aInstanceName : String) : TRTTIObject;
Var
	lObject : TRTTIObject;
	lCtrl : Integer;
Begin
	lObject := FindInstance(aInstanceName);
	Result := Instance(lObject.ClassName, UniqueID);
	For lCtrl := 0 To lObject.PropertyCount - 1 Do
		Result.PropertiesByIndex[lCtrl] := lObject.PropertiesByIndex[lCtrl];
End;

Function TRTTIClassFactory.FindInstance(Const aInstanceName : String): TRTTIObject;
Var
	lCtrl : Integer;
Begin
	Result := Nil;
	// Debug WriteLn('Searching instance ', aInstanceName, ' !');
	If fInstances.Count > 0 Then
		For lCtrl := 0 To fInstances.Count - 1 Do
			If (fInstances[lCtrl] As TRTTIObject).InstanceName = aInstanceName Then
			Begin
				// Debug WriteLn('Found !');
				Result := (fInstances[lCtrl] As TRTTIObject);
				Exit;
			End;
End;

// Issues a new unique ID
Function TRTTIClassFactory.UniqueID : String;
Begin
 Result := MDPrint(MDString(DateTimeToStr(Now()) + FloatToStr(Random()), MD_VERSION_5));;
End;

// Finds nameless instances and issues a new name to them
Procedure TRTTIClassFactory.FindNameless;
Var
	lCtrl : Integer;
Begin
	For lCtrl := 0 To fInstances.Count - 1 Do
		If (fInstances[lCtrl] As TRTTIObject).InstanceName = '' Then
			(fInstances[lCtrl] As TRTTIObject).InstanceName := UniqueID;
End;

Initialization

	Factory := TRTTIClassFactory.Create;

Finalization

	Factory.Free;

End.